perm filename CORD2.F4[CMS,LCS] blob sn#089288 filedate 1974-03-03 generic text, type T, neo UTF8
00100		COMMON IZ,KZ,F
00200		DIMENSION I(1),IA(1000),KC(6),KC7(6),KCN(6),KCN7(6),
00300		1KD(6),KD7(6),KDN(6),KDN7(6),KG(6),KG7(6),KGN(6),
00400		1KGN7(6),KA(6),KA7(6),KAN(6),KAN7(6),KB(6),KB7(6),
00500		1KBN(6),KBN7(6),KE(6),KE7(6),KEN(6),KEN7(6),KF(6),
00600		1KF7(6),KFN(6),KFN7(6),IX(25),IY(25),JX(25),JY(25)
00700		DATA KC/3,3,2,0,1,0/,KCN/3,3,5,5,4,3/,KC7/0,3,2,3,1,0/
00800		1,KCN7/3,3,5,3,4,6/,KD/0,0,0,2,3,2/,KDN/0,0,0,2,3,1/,
00900		1KD7/0,0,0,2,1,2/,KDN7/0,0,0,2,1,1/,KG/3,2,0,0,0,3/,
01000		1KGN/3,5,5,3,3,3/,KG7/3,2,0,0,0,1/,KGN7/3,5,5,3,6,3/,
01100		1KA/0,0,2,2,2,0/,KA7/0,0,2,1,2,0/,KAN/0,0,2,2,1,0/,
01200		1KAN7/0,0,2,2,1,3/,KB/2,2,4,4,4,2/,KB7/0,2,1,2,0,2/,
01300		1KBN/2,2,4,4,3,2/,KBN7/2,2,4,4,3,5/,KE/0,2,2,1,0,0/,
01400		1KE7/0,2,2,1,3,0/,KEN/0,2,2,0,0,0/,KEN7/0,2,2,0,3,0/,
01500		1KF/1,3,3,2,1,1/,KF7/1,3,1,2,4,1/,KFN/1,3,3,1,1,1/,
01600		1KFN7/1,3,3,1,4,1/,IX/100,150,200,250,300,350,100,
01700		1 100,100,100,100,100,100,100,100,100,100,100,100,
01800	  	1 100,215,215,215,215,190/,IY/420,420,420,420,420,
01900		1 420,420,350,280,210,140,70,0,-70,-140,-210,-280,
02000		1 -350,-420,425,245,105,-35,-245,-385/
02100		DATA JX/100,150,200,250,300,350,350,350,350,350,
02200		1 350,350,350,350,350,350,350,350,350,350,235,
02300		1 235,235,235,260/,JY/-420,-420,-420,-420,-420,-420,
02400		1 420,350,280,210,140,70,0,-70,-140,-210,-280,-350,
02500		1 -420,425,245,105,-35,-245,-385/
02600		Q=0
02700	2	TYPE 4
02800	4	FORMAT(' STARTING POINTS FOR X,Y,OR SIZE?'/)
02900		ACCEPT 3,IZ,KZ,F
03000	3	FORMAT(2I,F)
03100		IF(F.EQ.0)F=1
03200		GO TO 111
03300	1	IF(Q.EQ.1)GO TO 2
03400	111	TYPE 5
03500	5	FORMAT(' TYPE CHORD NAME'/)
03600		ACCEPT 10,A,B,N
03700		IF(A.EQ.'S')CALL SAVER(I)
03800		IF(A.EQ.'X')Q=1
03900		IF(Q.EQ.0.OR.A.EQ.'X')CALL DPYSET(2,IA,1000)
04000		IF(A.EQ.'X')GO TO 2
04100	10	FORMAT(2A1,I)
04200		DO 12 K=1,25  	            
04300		L1=IX(K)*F+IZ                
04400		L2=IY(K)*F+KZ                
04500		L3=JX(K)*F+IZ                
04600		L4=JY(K)*F+KZ                
04700	12	CALL ALINE(L1,L2,L3,L4)      
04800	 	IF(B.EQ.'7')N=7            
04900		IF(A.EQ.'C')GO TO 20
05000		IF(A.EQ.'D')GO TO 25
05100		IF(A.EQ.'G')GO TO 30
05200		IF(A.EQ.'A')GO TO 50
05300		IF(A.EQ.'B')GO TO 55
05400		IF(A.EQ.'E')GO TO 60
05500		IF(A.EQ.'F')GO TO 65
05600		GO TO 1 
05700	20	IF(B.EQ.'N')GO TO 33
05800		IF(N.EQ.7)CALL X(KC7)
05900		IF(N.EQ.0)CALL X(KC) 
06000		GO TO 1
06100	33	IF(N.EQ.7)CALL X(KCN7) 
06200		IF(N.EQ.0)CALL X(KCN) 
06300		GO TO 1
06400	25	IF(B.EQ.'N')GO TO 44
06500		IF(N.EQ.7)CALL X(KD7)
06600		IF(N.EQ.0)CALL X(KD)
06700		GO TO 1
06800	44	IF(N.EQ.7)CALL X(KDN7)
06900		IF(N.EQ.0)CALL X(KDN)
07000		GO TO 1
07100	30	IF(B.EQ.'N')GO TO 11
07200		IF(N.EQ.7)CALL X(KG7)
07300		IF(N.EQ.0)CALL X(KG)
07400		GO TO 1
07500	11	IF(N.EQ.7)CALL X(KGN7)
07600		IF(N.EQ.0)CALL X(KGN)
07700		GO TO 1
07800	50	IF(B.EQ.'N')GO TO 66
07900		IF(N.EQ.7)CALL X(KA7)
08000		IF(N.EQ.0)CALL X(KA)
08100		GO TO 1
08200	66	IF(N.EQ.7)CALL X(KAN7)
08300		IF(N.EQ.0)CALL X(KAN)
08400		GO TO 1
08500	55	IF(B.EQ.'N')GO TO 67
08600		IF(N.EQ.7)CALL X(KB7)
08700		IF(N.EQ.0)CALL X(KB)
08800		GO TO 1
08900	67	IF(N.EQ.7)CALL X(KBN7)
09000		IF(N.EQ.0)CALL X(KBN)
09100		GO TO 1
09200	60	IF(B.EQ.'N')GO TO 68
09300		IF(N.EQ.7)CALL X(KE7)
09400		IF(N.EQ.0)CALL X(KE)
09500		GO TO 1
09600	68	IF(N.EQ.7)CALL X(KEN7)
09700		IF(N.EQ.0)CALL X(KEN)
09800		GO TO 1
09900	65	IF(B.EQ.'N')GO TO 69
10000		IF(N.EQ.7)CALL X(KF7)
10100		IF(N.EQ.0)CALL X(KF)
10200		GO TO 1
10300	69	IF(N.EQ.7)CALL X(KFN7)
10400		IF(N.EQ.0)CALL X(KFN)
10500		GO TO 1
10600		END
10700	
10800		SUBROUTINE X(J)  
10900		DIMENSION J(1)
11000		COMMON IZ,KZ,F
11100		DO 1 L=1,6
11200		IF(J(L).EQ.0)GO TO 1
11300		M=(50+50*L)*F+IZ
11400		N=(455-70*J(L))*F+KZ
11500		NX=F*10
11600		CALL ALINE(M-NX,N+NX,M+NX,N-NX)
11700		CALL ALINE(M+NX,N+NX,M-NX,N-NX)
11800	1	CONTINUE
11900		REREAD 2,N
12000	2	FORMAT(A5)
12100		NB=F*6        
12200		IF(NB.LT.2)NB=2
12300		IF(NB.GT.7)NB=7
12400		CALL DPYBIG(NB)
12500		KX=-50*F+IZ
12600		KY=200*F+KZ
12700		CALL DPYTXT(KX,KY,N,1)
12800		CALL DPYOUT(2)
12900		RETURN
13000		END
13100	
13200		SUBROUTINE SAVER(I)
13300		DIMENSION I(1)
13400		I(1)=I(3)+2
13500		CALL SAVB(I)
13600	C SAVES DPY BUFFER IN FILE 'PLOTZ.DAT'
13700		END